home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / PASCAL / FPKPAS65.ZIP / SRCRTLDO.ZIP / SOURCE / RTL / DOS / SYSTEM.PP < prev    next >
Encoding:
Text File  |  1996-07-23  |  13.5 KB  |  576 lines

  1. {****************************************************************************
  2.  
  3.                    Copyright (c) 1993,96 by Florian Klämpfl
  4.  
  5.  ****************************************************************************}
  6.  
  7. { Unit System für DOS-Extender von DJ Delorie }
  8. {$define DOS}
  9. unit system;
  10.  
  11.   interface
  12.  
  13.     { die betriebssystemunabhangigen Deklarationen einfuegen: }
  14.  
  15.     {$I SYSTEMH.INC}
  16.     
  17.     {$I HEAPH.INC}
  18.  
  19.   implementation
  20.  
  21.     { die betriebssystemunabhängigen Implementationen einfuegen: }
  22.  
  23.     {$I SYSTEM.INC}
  24.  
  25.     type
  26.        plongint = ^longint;
  27.  
  28.     procedure halt;
  29.  
  30.       begin
  31.          asm
  32.             movl $0x4c00,%eax
  33.             int $0x21
  34.          end;
  35.       end;
  36.  
  37.     procedure halt(errnum : byte);
  38.  
  39.       begin
  40.          do_exit;
  41.          asm
  42.             movl $0x4c00,%eax
  43.             movb 8(%ebp),%al
  44.             int $0x21
  45.          end;
  46.       end;
  47.  
  48.     function paramcount : longint;
  49.  
  50.       begin
  51.          asm
  52.             movl _argc,%eax
  53.             decl %eax
  54.             leave
  55.             ret
  56.          end ['EAX'];
  57.       end;
  58.  
  59.     function paramstr(l : longint) : string;
  60.  
  61.       function args : pointer;
  62.  
  63.         begin
  64.            asm
  65.               movl _args,%eax
  66.               leave
  67.               ret
  68.            end ['EAX'];
  69.         end;
  70.  
  71.       var
  72.          p : ^pchar;
  73.  
  74.       begin
  75.          if (l>=0) and (l<=paramcount) then
  76.            begin
  77.               p:=args;
  78.               paramstr:=strpas(p[l]);
  79.            end
  80.          else paramstr:='';
  81.       end;
  82.  
  83.     procedure randomize;
  84.  
  85.       var
  86.          hl : longint;
  87.  
  88.       begin
  89.          asm
  90.             movb $0x2c,%ah
  91.             int $0x21
  92.             movw %cx,-4(%ebp)
  93.             movw %dx,-2(%ebp)
  94.          end;
  95.          randseed:=hl;
  96.       end;
  97.  
  98. { use standard heap management }
  99. {$I HEAP.INC}
  100.  
  101. {****************************************************************************
  102.                     Unterprogramme zu Dateiverwaltung
  103.  ****************************************************************************}
  104.  
  105.     procedure do_close(h : longint);
  106.  
  107.       begin
  108.          asm
  109.             movl 8(%ebp),%ebx
  110.             movb $0x3e,%ah
  111.             pushl %ebp
  112.             intl $0x21
  113.             popl %ebp
  114.          end;
  115.       end;
  116.  
  117.     procedure fileclosefunc(var t : textrec);
  118.  
  119.       begin
  120.          do_close(t.handle);
  121.       end;
  122.  
  123.     function open(f : pchar;flags : longint) : longint;
  124.  
  125.       begin
  126.          asm
  127.             movw $0xff02,%ax
  128.         movl 8(%ebp),%ebx
  129.             movl 12(%ebp),%ecx
  130.             int $0x21
  131.             jnc LOPEN1
  132.             movw %ax,U_SYSTEM_INOUTRES;
  133.             xorl %eax,%eax
  134.          LOPEN1:
  135.             // Returnwert ist in EAX
  136.             leave
  137.             ret $8
  138.          end;
  139.       end;
  140.  
  141.     procedure doserase(p : pchar);
  142.  
  143.       begin
  144.          asm
  145.             movl 8(%ebp),%edx
  146.             movb $0x41,%ah
  147.             pushl %ebp
  148.             int $0x21
  149.             popl %ebp
  150.             jnc LERASE1
  151.             movw %ax,U_SYSTEM_INOUTRES;
  152.          LERASE1:
  153.          end;
  154.       end;
  155.  
  156.     procedure dosrename(p1,p2 : pchar);
  157.  
  158.       begin
  159.          asm
  160.             movl 8(%ebp),%edx
  161.             movl 12(%ebp),%edi
  162.             movb $0x56,%ah
  163.             pushl %ebp
  164.             int $0x21
  165.             popl %ebp
  166.             jnc LRENAME1
  167.             movw %ax,U_SYSTEM_INOUTRES;
  168.          LRENAME1:
  169.          end;
  170.       end;
  171.  
  172.     procedure doswrite(h,addr,len : longint);
  173.  
  174.       begin
  175.          asm
  176.             movl 16(%ebp),%ecx
  177.             movl 12(%ebp),%edx
  178.             movl 8(%ebp),%ebx
  179.             movb $0x40,%ah
  180.             int $0x21
  181.             jnc LDOSWRITE1
  182.             movw %ax,U_SYSTEM_INOUTRES;
  183.          LDOSWRITE1:
  184.          end;
  185.       end;
  186.  
  187.     function dosread(h,addr,len : longint) : longint;
  188.  
  189.       begin
  190.          asm
  191.             movl 16(%ebp),%ecx
  192.             movl 12(%ebp),%edx
  193.             movl 8(%ebp),%ebx
  194.             movb $0x3f,%ah
  195.             int $0x21
  196.             jnc LDOSREAD1
  197.             movw %ax,U_SYSTEM_INOUTRES;
  198.             xorl %eax,%eax
  199.          LDOSREAD1:
  200.             leave
  201.             ret $12
  202.          end;
  203.       end;
  204.  
  205.     function dosfilepos(handle : longint) : longint;
  206.  
  207.       begin
  208.          asm
  209.             movb $0x42,%ah
  210.             movb $0x1,%al
  211.             movl 8(%ebp),%ebx
  212.             xorl %ecx,%ecx
  213.             xorl %edx,%edx
  214.             pushl %ebp
  215.             int $0x21
  216.             popl %ebp
  217.             jnc LDOSFILEPOS1
  218.             movw %ax,U_SYSTEM_INOUTRES;
  219.             xorl %eax,%eax
  220.             jmp LDOSFILEPOS2
  221.          LDOSFILEPOS1:
  222.             shll $16,%edx
  223.             movzwl %ax,%eax
  224.             orl %edx,%eax
  225.          LDOSFILEPOS2:
  226.             leave
  227.             ret $4
  228.          end;
  229.       end;
  230.  
  231.     procedure dosseek(handle : longint;pos : longint);
  232.  
  233.       begin
  234.          asm
  235.             movb $0x42,%ah
  236.             xorb %al,%al
  237.             movl 8(%ebp),%ebx
  238.             movl 12(%ebp),%edx
  239.             // ginge auch mit SHLD
  240.             movl %edx,%ecx
  241.             shrl $16,%ecx
  242.             pushl %ebp
  243.             int $0x21
  244.             popl %ebp
  245.             jnc LDOSSEEK1
  246.             movw %ax,U_SYSTEM_INOUTRES;
  247.          LDOSSEEK1:
  248.          end;
  249.       end;
  250.  
  251.     function dosfilesize(handle : longint) : longint;
  252.  
  253.       function set_at_end(handle : longint) : longint;
  254.  
  255.         begin
  256.            asm
  257.               movb $0x42,%ah
  258.               movb $0x2,%al
  259.               // Vorsicht Stack: 0 %ebp; 4 retaddr;
  260.               // 8 nextstackframe; 12 handle
  261.               movl 12(%ebp),%ebx
  262.               xorl %ecx,%ecx
  263.               xorl %edx,%edx
  264.               pushl %ebp
  265.               int $0x21
  266.               popl %ebp
  267.               jnc Lset_at_end1
  268.               movw %ax,U_SYSTEM_INOUTRES;
  269.               xorl %eax,%eax
  270.               jmp Lset_at_end2
  271.            Lset_at_end1:
  272.               shll $16,%edx
  273.               movzwl %ax,%eax
  274.               orl %edx,%eax
  275.            Lset_at_end2:
  276.               leave
  277.               ret $8
  278.            end;
  279.          end;
  280.  
  281.       var
  282.          tempfilesize : longint;
  283.          aktfilepos : longint;
  284.  
  285.       begin
  286.          aktfilepos:=dosfilepos(handle);
  287.          tempfilesize:=set_at_end(handle);
  288.          dosseek(handle,aktfilepos);
  289.          dosfilesize:=tempfilesize;
  290.       end;
  291.  
  292.     procedure fileopenfunc(var f : textrec);
  293.  
  294.       var
  295.          b : array[0..255] of char;
  296.  
  297.       begin
  298.          move(f.name[1],b,length(f.name));
  299.          b[length(f.name)]:=#0;
  300.          f.inoutfunc:=@fileinoutfunc;
  301.          f.flushfunc:=@fileinoutfunc;
  302.          f.closefunc:=@fileclosefunc;
  303.          case f.mode of
  304.             fminput : f.handle:=open(b,$8001);
  305.             fmoutput : f.handle:=open(b,$8302);
  306.          end;
  307.       end;
  308.  
  309.     function eof(var t : text) : boolean;[iocheck];
  310.  
  311.       begin
  312.          eof:=dosfilesize(textrec(t).handle)<=dosfilepos(textrec(t).handle);
  313.          if eof then
  314.            eof:=textrec(t).bufend<=textrec(t).bufpos;
  315.       end;
  316.  
  317.     procedure rewrite(var f : file;l : word);[iocheck];
  318.  
  319.       var
  320.          b : array[0..255] of char;
  321.  
  322.       begin
  323.          filerec(f).mode:=fmoutput;
  324.          move(filerec(f).name[1],b,length(filerec(f).name));
  325.          b[length(filerec(f).name)]:=#0;
  326.        filerec(f).handle:=open(b,$8302);
  327.        filerec(f).recsize:=l;
  328.       end;
  329.  
  330.     procedure reset(var f : file;l : word);[iocheck];
  331.  
  332.       var
  333.          b : array[0..255] of char;
  334.  
  335.       begin
  336.          move(filerec(f).name[1],b,length(filerec(f).name));
  337.          b[length(filerec(f).name)]:=#0;
  338.          {
  339.            filerec(f).mode:=fminput;
  340.            filerec(f).handle:=open(b,$8001);
  341.          }
  342.          case filemode of
  343.             0 : begin
  344.                    filerec(f).mode:=fminput;
  345.                    filerec(f).handle:=open(b,$8001);
  346.                 end;
  347.             1 : begin
  348.                    filerec(f).mode:=fmoutput;
  349.                    filerec(f).handle:=open(b,$8302);
  350.                 end;
  351.             2 : begin
  352.                    filerec(f).mode:=fminout;
  353.                    filerec(f).handle:=open(b,$8404);
  354.                 end;
  355.          end;
  356.        filerec(f).recsize:=l;
  357.       end;
  358.  
  359.     procedure rewrite(var f : file);[iocheck];
  360.  
  361.        begin
  362.           rewrite(f,128);
  363.        end;
  364.  
  365.     procedure reset(var f : file);[iocheck];
  366.  
  367.        begin
  368.           reset(f,128);
  369.        end;
  370.  
  371.     procedure blockwrite(var f : file;var buf;count : longint);[iocheck];
  372.  
  373.        var
  374.           p : pointer;
  375.           size : longint;
  376.  
  377.         begin
  378.            p:=@buf;
  379.            doswrite(filerec(f).handle,longint(p),count*filerec(f).recsize);
  380.         end;
  381.  
  382.     procedure blockread(var f : file;var buf;count : longint;var result : longint);[iocheck];
  383.  
  384.       begin
  385.          result:=dosread(filerec(f).handle,longint(@buf),
  386.            count*filerec(f).recsize) div filerec(f).recsize;
  387.       end;
  388.  
  389.     procedure blockread(var f : file;var buf;count : longint);[iocheck];
  390.  
  391.       var
  392.          result : longint;
  393.  
  394.       begin
  395.          blockread(f,buf,count,result);
  396.       end;
  397.  
  398.     function filepos(var f : file) : longint;[iocheck];
  399.  
  400.       begin
  401.          filepos:=dosfilepos(filerec(f).handle) div filerec(f).recsize;
  402.       end;
  403.  
  404.     function filesize(var f : file) : longint;[iocheck];
  405.  
  406.       begin
  407.          filesize:=dosfilesize(filerec(f).handle) div filerec(f).recsize;
  408.       end;
  409.  
  410.     function eof(var f : file) : boolean;[iocheck];
  411.  
  412.       begin
  413.          eof:=filesize(f)<=filepos(f);
  414.       end;
  415.  
  416.     procedure seek(var f : file;pos : longint);[iocheck];
  417.  
  418.       begin
  419.          dosseek(filerec(f).handle,pos*filerec(f).recsize);
  420.       end;
  421.  
  422.     procedure close(var f : file);[iocheck];
  423.  
  424.       begin
  425.          if (filerec(f).mode<>fmclosed) then
  426.            begin
  427.               filerec(f).mode:=fmclosed;
  428.               do_close(filerec(f).handle);
  429.            end;
  430.       end;
  431.       
  432.     procedure dos_dirs(func : byte;name : pchar);
  433.     
  434.       begin
  435.          asm
  436.             movl 10(%ebp),%edx
  437.             movb 8(%ebp),%ah
  438.             int $0x21
  439.             jnc LDOS_DIRS1
  440.             movw %ax,U_SYSTEM_INOUTRES;
  441.          LDOS_DIRS1:
  442.             leave
  443.             ret $6
  444.          end;
  445.       end;
  446.  
  447.     procedure _dir(func : byte;const s : string);
  448.     
  449.       var
  450.          buffer : array[0..255] of char;
  451.  
  452.       begin
  453.          move(s[1],buffer,length(s));
  454.          buffer[length(s)]:=#0;
  455.          dos_dirs(func,buffer);
  456.       end;
  457.  
  458.     procedure mkdir(const s : string);
  459.  
  460.       begin
  461.          _dir($39,s);
  462.       end;
  463.  
  464.     procedure rmdir(const s : string);
  465.  
  466.       begin
  467.          _dir($3a,s);
  468.       end;
  469.  
  470.     procedure chdir(const s : string);
  471.  
  472.       begin
  473.          _dir($3b,s);
  474.       end;
  475.  
  476.     { thanks to Michael Van Canneyt <michael@tfdec1.fys.kuleuven.ac.be>, }
  477.     { who writes this code                                               }
  478.     procedure getdir(drivenr : byte;var dir : string);
  479.  
  480.       var
  481.          temp : string;
  482.          sof : pointer;
  483.          i : byte;
  484.  
  485.       begin
  486.          sof:=@dir[4];
  487.  
  488.          { dir[1..3] will contain '[drivenr]:\', but is not }
  489.          { supplied by DOS, so we let dos string start at   }
  490.          { dir[4]                                           }
  491.          asm
  492.             { Get dir from drivenr : 0=default, 1=A etc... }
  493.             movb drivenr,%dl
  494.  
  495.             { put (previously saved) offset in si }
  496.             movl sof,%esi
  497.  
  498.             { call msdos function 47H : Get dir }
  499.             mov $0x47,%ah
  500.  
  501.             { make the call }
  502.             int $0x21
  503.  
  504.             { Rem: if call unsuccesfull, carry is set, and AX has }
  505.             { error code                                          }
  506.  
  507.  
  508.          end;
  509.          { Now Dir should be filled with directory in ASCIIZ, }
  510.          { starting from dir[4]                               }
  511.          dir[0]:=#3;
  512.          dir[2]:=':';
  513.          dir[3]:='\';
  514.  
  515.          i:=4;
  516.  
  517.          { conversation to Pascal string }
  518.          while (dir[i]<>#0) do
  519.            begin
  520.               { convert path name to DOS }
  521.               if dir[i]='/' then
  522.                 dir[i]:='\';
  523.               dir[0]:=chr(i);
  524.               inc(i);
  525.            end;
  526.          { upcase the string (FPKPascal function) }
  527.          dir:=upcase(dir);
  528.          if drivenr<>0 then   { Drive was supplied. We know it }
  529.            dir[1]:=chr(65+drivenr-1)
  530.          else
  531.            begin
  532.               { We need to get the current drive from DOS function 19H  }
  533.               { because the drive was the default, which can be unknown }
  534.               asm
  535.                  movb $0x19,%ah
  536.                  int $0x21
  537.                  addb $65,%al
  538.                  movb %al,i
  539.               end;
  540.               dir[1]:=chr(i)
  541.            end;
  542.       end;
  543.  
  544.   var
  545.      i : longint;
  546.  
  547. begin
  548.    exitproc:=nil;
  549.    { Heapmanagement initialisieren }
  550.    {
  551.    for i:=1 to 32 do
  552.      blocks[i]:=nil;
  553.    }
  554.    heaporg:=getheapstart;
  555.    heapptr:=heaporg;
  556.    _memavail:=getheapsize;
  557.    heapend:=heaporg+_memavail;
  558.    heaperror:=nil;
  559.    freelist:=nil;
  560.    { Standartinput initialisieren }
  561.    assign(input,'');
  562.    textrec(input).handle:=0;
  563.    textrec(input).mode:=fminput;
  564.    textrec(input).inoutfunc:=@fileinoutfunc;
  565.    textrec(input).flushfunc:=@fileinoutfunc;
  566.    { Standartoutput initialisieren }
  567.    assign(output,'');
  568.    textrec(output).handle:=1;
  569.    textrec(output).mode:=fmoutput;
  570.    textrec(output).inoutfunc:=@fileinoutfunc;
  571.    textrec(output).flushfunc:=@fileinoutfunc;
  572.    textrec(input).mode:=fminput;
  573.    { kein Ein- Ausgabefehler }
  574.    inoutres:=0;
  575. end.
  576.